home *** CD-ROM | disk | FTP | other *** search
/ Almathera Ten Pack 3: CDPD 3 / Almathera Ten on Ten - Disc 3: CDPD3.iso / fish / 001-100 / 001-025 / 018 / xlisp1.6 / pt.lsp < prev    next >
Lisp/Scheme  |  1995-03-17  |  4KB  |  168 lines
  1. ; This is a sample XLISP program
  2. ; It implements a simple form of programmable turtle for VT100 compatible
  3. ; terminals.
  4.  
  5. ; To run it:
  6.  
  7. ;    A>xlisp pt
  8.  
  9. ; This should cause the screen to be cleared and two turtles to appear.
  10. ; They should each execute their simple programs and then the prompt
  11. ; should return.  Look at the code to see how all of this works.
  12.  
  13. ; Get some more memory
  14. (expand 1)
  15.  
  16. ; Clear the screen
  17. (defun clear ()
  18.     (princ "\e[H\e[J"))
  19.  
  20. ; Move the cursor
  21. (defun setpos (x y)
  22.     (princ "\e[") (princ y) (princ ";") (princ x) (princ "H"))
  23.  
  24. ; Kill the remainder of the line
  25. (defun kill ()
  26.     (princ "\e[K"))
  27.  
  28. ; Move the cursor to the currently set bottom position and clear the line
  29. ;  under it
  30. (defun bottom ()
  31.     (setpos bx (+ by 1))
  32.     (kill)
  33.     (setpos bx by)
  34.     (kill))
  35.  
  36. ; Clear the screen and go to the bottom
  37. (defun cb ()
  38.     (clear)
  39.     (bottom))
  40.  
  41.  
  42. ; ::::::::::::
  43. ; :: Turtle ::
  44. ; ::::::::::::
  45.  
  46. ; Define "Turtle" class
  47. (setq Turtle (Class :new '(xpos ypos char)))
  48.  
  49. ; Answer ":isnew" by initing a position and char and displaying.
  50. (Turtle :answer :isnew '() '(
  51.     (setq xpos (setq newx (+ newx 1)))
  52.     (setq ypos 12)
  53.     (setq char "*")
  54.     (self :display)
  55.     self))
  56.  
  57. ; Message ":display" prints its char at its current position
  58. (Turtle :answer :display '() '(
  59.     (setpos xpos ypos)
  60.     (princ char)
  61.     (bottom)
  62.     self))
  63.  
  64. ; Message ":char" sets char to its arg and displays it
  65. (Turtle :answer :char '(c) '(
  66.     (setq char c)
  67.     (self :display)))
  68.  
  69. ; Message ":goto" goes to a new place after clearing old one
  70. (Turtle :answer :goto '(x y) '(
  71.     (setpos xpos ypos) (princ " ")
  72.     (setq xpos x)
  73.     (setq ypos y)
  74.     (self :display)))
  75.  
  76. ; Message ":up" moves up if not at top
  77. (Turtle :answer :up '() '(
  78.     (if (> ypos 0)
  79.     (self :goto xpos (- ypos 1))
  80.     (bottom))))
  81.  
  82. ; Message ":down" moves down if not at bottom
  83. (Turtle :answer :down '() '(
  84.     (if (< ypos by)
  85.     (self :goto xpos (+ ypos 1))
  86.     (bottom))))
  87.  
  88. ; Message ":right" moves right if not at right
  89. (Turtle :answer :right '() '(
  90.     (if (< xpos 80)
  91.     (self :goto (+ xpos 1) ypos)
  92.     (bottom))))
  93.  
  94. ; Message ":left" moves left if not at left
  95. (Turtle :answer :left '() '(
  96.     (if (> xpos 0)
  97.     (self :goto (- xpos 1) ypos)
  98.     (bottom))))
  99.  
  100.  
  101. ; :::::::::::::
  102. ; :: PTurtle ::
  103. ; :::::::::::::
  104.  
  105. ; Define "DPurtle" programable turtle class
  106. (setq PTurtle (Class :new '(prog pc) '() Turtle))
  107.  
  108. ; Message ":program" stores a program
  109. (PTurtle :answer :program '(p) '(
  110.     (setq prog p)
  111.     (setq pc prog)
  112.     self))
  113.  
  114. ; Message ":step" executes a single program step
  115. (PTurtle :answer :step '() '(
  116.     (if (null pc)
  117.     (setq pc prog))
  118.     (if pc
  119.     (progn (self (car pc))
  120.            (setq pc (cdr pc))))
  121.     self))
  122.  
  123. ; Message ":step#" steps each turtle program n times
  124. (PTurtle :answer :step# '(n) '(
  125.     (dotimes (x n) (self :step))
  126.     self))
  127.  
  128.  
  129. ; ::::::::::::::
  130. ; :: PTurtles ::
  131. ; ::::::::::::::
  132.  
  133. ; Define "PTurtles" class
  134. (setq PTurtles (Class :new '(turtles)))
  135.  
  136. ; Message ":make" makes a programable turtle and adds it to the collection
  137. (PTurtles :answer :make '(x y &aux newturtle) '(
  138.     (setq newturtle (PTurtle :new))
  139.     (newturtle :goto x y)
  140.     (setq turtles (cons newturtle turtles))
  141.     newturtle))
  142.  
  143. ; Message ":step" steps each turtle program once
  144. (PTurtles :answer :step '() '(
  145.     (mapcar '(lambda (turtle) (turtle :step)) turtles)
  146.     self))
  147.  
  148. ; Message ":step#" steps each turtle program n times
  149. (PTurtles :answer :step# '(n) '(
  150.     (dotimes (x n) (self :step))
  151.     self))
  152.  
  153.  
  154. ; Initialize things and start up
  155. (setq bx 0)
  156. (setq by 20)
  157. (setq newx 0)
  158.  
  159. ; Create some programmable turtles
  160. (cb)
  161. (setq turtles (PTurtles :new))
  162. (setq t1 (turtles :make 40 10))
  163. (setq t2 (turtles :make 41 10))
  164. (t1 :program '(:left :right :up :down))
  165. (t2 :program '(:right :left :down :up))
  166.  
  167.  
  168.